unit PopupTrackBar;

interface

uses Classes, StdCtrls, ComCtrls, Windows, Messages, Forms, Controls, Graphics;

const
  LabelWidth = 50;
  TrackbarWidth = 225;

type
  TSetValueEvent = procedure(Sender: TObject; var Value: Double; Data: TObject) of object;



  TTrackBar2 = class(TTrackBar)
  published
    property OnMouseUp;
  end;

  TPopupTrackBar = class(TComponent)
  private
    FForm: TForm;
    FTrackBar: TTrackBar2;
    FLabel: TLabel;
    FData: TObject;

    FWidth: Integer;
    FHeight: Integer;
    FOldValue: Double;
    FValue: Double;
    FMinValue: Double;
    FMaxValue: Double;

    FOnSetValue: TSetValueEvent;
    procedure Close;
    procedure SetFormPosition;
    procedure SetValue(AValue: Double);
    procedure FormDeactivate(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure TrackbarChange(Sender: TObject);
    procedure TrackbarMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  public
    destructor Destroy; override;
    procedure Popup(Data: TObject; InitialValue: Double);
    procedure AfterConstruction; override;
  published
    property Value: Double read FValue write FValue;
    property Height: Integer read FHeight write FHeight;
    property Width: Integer read FWidth write FWidth;
    property OnSetValue: TSetValueEvent read FOnSetValue write FOnSetValue;
  end;

procedure Register;

implementation

uses CommCtrl, Math, SysUtils, ExtCtrls;

procedure Register;
begin
  RegisterComponents('CPControls', [TPopupTrackbar]);
end;

{ TPopupTrackBar }

procedure TPopupTrackBar.AfterConstruction;
begin
  FWidth := TrackbarWidth + LabelWidth;
  FHeight := 36;
  FValue := 0;
end;

procedure TPopupTrackBar.Close;
begin
  if FForm = nil then
    exit;
  FForm.OnDeactivate := nil;
  FForm.Close;
  FForm.Free;
  FForm := nil;
  FTrackBar := nil;
end;

destructor TPopupTrackBar.Destroy;
begin
  Close;
  inherited;
end;

procedure TPopupTrackBar.FormDeactivate(Sender: TObject);
begin
  SetValue(FOldValue);
  Close;
end;

procedure TPopupTrackBar.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = VK_ESCAPE then
  begin
    SetValue(FOldValue);
    Close;
  end;
end;

procedure TPopupTrackBar.Popup(Data: TObject; InitialValue: Double);
var
  D: Double;
  Bevel: TBevel;
  Panel: TPanel;
begin
  // Create form:
  Application.CreateForm(TForm, FForm);
  FForm.Width := FWidth;
  FForm.Height := FHeight;
  FForm.BorderStyle := bsNone;
  FForm.FormStyle := fsStayOnTop;
  FForm.KeyPreview := true;

  Bevel := TBevel.Create(FForm);
  Bevel.Parent := FForm;
  Bevel.SetBounds(0, 0, FWidth, FHeight);
  Bevel.Style := bsRaised;


  FTrackBar := TTrackBar2.Create(FForm);
  FTrackBar.Parent := FForm;
  FTrackBar.SetBounds(-1, -1, FWidth - LabelWidth + 2, FHeight + 2);
  FTrackBar.ThumbLength := 23;
  FTrackBar.Min := 0;
  FTrackBar.Max := 200;
  FTrackBar.Frequency := 100;
  FTrackBar.TickStyle := tsAuto;
  FTrackBar.TickMarks := tmBottomRight;

  Panel := TPanel.Create(FForm);
  Panel.Parent := FForm;
  Panel.BevelInner := bvNone;
  Panel.BevelOuter := bvNone;
  Panel.SetBounds(FWidth - LabelWidth, 1, LabelWidth - 5, FHeight - 2);

  FLabel := TLabel.Create(Panel);
  FLabel.Parent := Panel;
  FLabel.Transparent := false;
  FLabel.AutoSize := false;
  FLabel.Align := alClient;
  FLabel.ParentColor := true;
  FLabel.Layout := tlCenter;
  FLabel.Alignment := taRightJustify;

  // Setup minimum, maximum and position of trackbar:
  FOldValue := InitialValue;
  FValue := InitialValue;
  FMaxValue := IntPower(10, Ceil(Log10(Max(0.1, Abs(FValue) / 0.75))));
  FMinValue := -FMaxValue;
  D := (FValue - FMinValue) / (FMaxValue - FMinValue);
  FTrackBar.Position := Round(D * (FTrackBar.Max - FTrackBar.Min) + FTrackBar.Min);

  FData := Data;

  // Place form:
  SetFormPosition;

  // Set events:
  FTrackBar.OnChange := TrackBarChange;
  FTrackBar.OnMouseUp := TrackBarMouseUp;
  FForm.OnDeactivate := FormDeactivate;
  FForm.OnKeyDown := FormKeyDown;

  SetValue(FValue);

  //Show form:
  FForm.Show;
end;

procedure TPopupTrackBar.SetFormPosition;
var
  R: TRect;
  P, MP: TPoint;
begin
  SendMessage(FTrackBar.Handle, TBM_GETTHUMBRECT, 0, Integer(@R));
  // OffsetRect(R, TrackBar.Left, TrackBar.Top);
  // Center position of trackbar slider in trackbar client coordinates:
  P := Point((R.Right + R.Left) div 2, (R.Bottom + R.Top) div 2);
  MP := Mouse.CursorPos;
  FForm.SetBounds(MP.X - P.X, MP.Y - P.Y, FForm.Width, FForm.Height);
  mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0); // Suppresses weird dragging
  mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);
end;

procedure TPopupTrackBar.SetValue(AValue: Double);
begin
  if @FOnSetValue <> nil then
    FOnSetValue(self, AValue, FData);
  FLabel.Caption := FloatToStrF(AValue, ffGeneral, 5, 5);
end;

procedure TPopupTrackBar.TrackbarChange(Sender: TObject);
begin
  FValue := ((FTrackBar.Position - FTrackBar.Min) * (FMaxValue - FMinValue)) /
    (FTrackBar.Max - FTrackBar.Min) + FMinValue;
  SetValue(FValue);
end;

procedure TPopupTrackBar.TrackbarMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Close;
end;

end.
